home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / tool+ / popUpMenus < prev    next >
Encoding:
Text File  |  1993-06-23  |  4.1 KB  |  136 lines  |  [TEXT/YERK]
  1. \ stringvar - class of strings which are kept in memory
  2. \             as barrays and have a max length - from mh
  3. \ 5.24.89    rfl    twidth and type replaces stringwidth and drawstring
  4. \                 inset rect before print and changed 2 to 1 in justification
  5. \ 12.4.89    rfl a few modifications cosmetic
  6. \ 5.24.90    rfl    redid justinbox stuff to shorten code
  7. \ 7.12.92    rfl    deleted stringvar class
  8. \ 5.20.93    rfl    removed cursor stuff
  9.  
  10. \ Bitmap class for drawing bitmaps to screen
  11. :CLASS bMap  <Super warray
  12.  
  13.     Var        BaseAddr
  14.     Int        RowBytes
  15.     Rect    BndsRect
  16.     rect    DestRect
  17.  
  18.     \ (  n  l t r b -- )
  19.     :M  INIT:   Put:  bndsRect  Put: RowBytes  ;M
  20.  
  21.     :M putDest: { x y \ x0 y0 -- } size: BndsRect -> y0 -> x0
  22.             x y x0 x + y0 y + put: destRect ;M
  23.  
  24.     :M draw: idxbase +base Put: BaseAddr
  25.             abs: self portBit: actw
  26.             abs: BndsRect abs: destRect
  27.             word0 0 call copyBits ;M
  28.  
  29.     :M offset: ( dx dy -- ) offset: destrect ;M
  30.  
  31.     :M moveto: ( x y -- ) putDest: self draw: self ;M
  32.  
  33. ;CLASS
  34.  
  35. 5 bmap darrow    \ instantiate a global down pointing arrow
  36. hex
  37. $ ff80 $ 7f00 $ 3e00 $ 1c00 $ 0800  put: darrow
  38. decimal
  39. 2 0 0 9 5 init: darrow
  40.  
  41. \ draw text string justified in a given rectangle
  42. : ctextbox { addr len arect just -- }
  43.         addr +base len aRect +base just makeint call textbox ;
  44.  
  45. \ definition of class that handles popup menus
  46.  
  47. \ popupRect provides a way to use pmenu
  48. \    two kinds of disp/print are supported:
  49. \        display a fixed name string or
  50. \        display the last selected item in menu
  51.  
  52. :CLASS popUpMenu <super pMenu
  53.     int            dmode        \ display mode: ITEM (0) or NAME (1)
  54.     var            myAction    \ Menu has an action independent of item handler
  55.     var            myWindow    \ owning window
  56. 33    bytes        name        \ string holds name of rect...limited to 32 characters
  57.     int         txFont      \ retains its type of font
  58.     int         txSize
  59.     int         txFace
  60.     int            txJust        \ justification left(0), center(1), right(-1)
  61.     rect        myBorder    \ rectangle framing menu
  62.  
  63.   :M placeDarrow: getBotX: myBorder
  64.         13 - size: myBorder swap drop 2/ getTopY: myBorder + 2- putDest: darrow ;M
  65.  
  66. \ *** initializing methods ***
  67.   :M font: ( font size face -- ) put: txFace put: txSize put: txFont ;M
  68.   :M justify: put: txJust ;M
  69.   :M actions: put: myAction ;M
  70.   :M putWindow: put: myWindow ;M
  71.   :M setMode: ( displayMode -- ) put: dmode ;M
  72.   :M putRect: ( l t r b -- ) put: myBorder placeDarrow: self
  73.         getTop: myBorder offset: self ;M
  74.  
  75.   :M initFont: pushPort set: [ obj: myWindow ]
  76.         get: txFont tfont get: txSize tsize get: txFace tface popPort ;M
  77.  
  78.   :M getRect: ( -- topx topy botx boty ) get: myBorder ;M
  79.  
  80.   :M name: ( addr len -- ) dup 32 > classerr" 133 addr: name >str255 drop ;M
  81.  
  82.   :M getName: ( -- addr len ) addr: name count ;M
  83.  
  84.   :M print: ( -- ) actw obj: myWindow -> actw
  85.         2 1 inset: myBorder getBotX: myBorder dup 10 - putBotX: myBorder
  86.         1 tmode initFont: self
  87.         getName: self addr: myBorder get: txJust ctextBox 
  88.         putBotX: myBorder -2 -1 inset: myBorder  placeDarrow: self draw: darrow
  89.         -> actw ;M
  90.  
  91.   :M draw: ( -- ) pushPort set: [ obj: myWindow ]
  92.         1 1 offset: myBorder draw: myBorder
  93.         -1 -1 offset: myBorder clear: myBorder draw: myBorder print: self popPort ;M
  94.  
  95.   :M ptIn: ( point --) ptIn: myBorder ;M
  96.  
  97.   :M exec: ( -- ) where: theMouse pack ptin: self
  98.         IF popup: self
  99.             get: dmode 0=
  100.             IF  mitem 0>
  101.                 IF    mitem checkOne: self mitem 1- getText: self name: self print: self THEN
  102.             THEN
  103.             exec: myAction
  104.         THEN ;M
  105.  
  106. \   :M firstName: get: dmode 0=
  107. \         IF getItem: self  get: super
  108. \             name: self print: self
  109. \         THEN ;M
  110.  
  111.   :M classinit: ( -- )  classinit: super
  112.         12 put: txSize 1 put: type  nullcfa put: myAction ;M
  113.  
  114. ;CLASS
  115.  
  116. \ EXAMPLE - create a menu in a resource file with ID 128 and 4 items
  117. \ " .rsrc" openresfile
  118. \ 
  119. \ 4 popUpMenu SampleMen        \ instantiate
  120. \ : itemHandler home mitem . ;
  121. \ 4 'cfas itemHandler itemHandler itemHandler itemHandler 128 put: SampleMen
  122. \ fwind putWindow: SampleMen
  123. \ 
  124. \ 240 18 320 34 putRect: SampleMen
  125. \ 0 12 0 font: SampleMen
  126. \ konstant tejustleft justify: SampleMen
  127. \ 
  128. \ getnew: SampleMen        \ read menu from resource file
  129. \ insert: SampleMen        \ insert it into the menubar
  130. \ 
  131. \ : doSample exec: sampleMen ;
  132. \ : drawSample draw: sampleMen ;
  133. \ 4 'cfas null null drawSample doSample actions: fwind
  134. \ 
  135. \ draw: sampleMen
  136.